home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / INIT.LSP < prev    next >
Text File  |  1994-02-05  |  79KB  |  1,898 lines
  1. ;;;;   INITIALISIERUNGS-FILE
  2.  
  3. (in-package "LISP")
  4.  
  5. (shadow 'system::debug (find-package "SYSTEM"))
  6.  
  7. ;;; Exportierungen:
  8. (export '(
  9. ;; Typen:
  10. array atom bignum bit bit-vector character common compiled-function
  11. complex cons double-float fixnum float function hash-table integer keyword
  12. list long-float nil null number package pathname random-state ratio
  13. rational readtable real sequence short-float simple-array simple-bit-vector
  14. simple-string simple-vector single-float standard-char stream string
  15. string-char symbol t vector satisfies values mod signed-byte unsigned-byte
  16. ;; Konstanten:
  17. lambda-list-keywords lambda-parameters-limit nil t call-arguments-limit
  18. multiple-values-limit pi boole-clr boole-set boole-1 boole-2 boole-c1 boole-c2
  19. boole-and boole-ior boole-xor boole-eqv boole-nand boole-nor boole-andc1
  20. boole-andc2 boole-orc1 boole-orc2 most-positive-fixnum most-negative-fixnum
  21. most-positive-short-float least-positive-short-float least-negative-short-float
  22. most-negative-short-float most-positive-single-float
  23. least-positive-single-float least-negative-single-float
  24. most-negative-single-float most-positive-double-float
  25. least-positive-double-float least-negative-double-float
  26. most-negative-double-float most-positive-long-float least-positive-long-float
  27. least-negative-long-float most-negative-long-float short-float-epsilon
  28. single-float-epsilon double-float-epsilon long-float-epsilon
  29. short-float-negative-epsilon single-float-negative-epsilon
  30. double-float-negative-epsilon long-float-negative-epsilon
  31. char-code-limit char-font-limit char-bits-limit char-control-bit char-meta-bit
  32. char-super-bit char-hyper-bit array-rank-limit array-dimension-limit
  33. array-total-size-limit internal-time-units-per-second
  34. ;; Variablen:
  35. *macroexpand-hook* *package* *modules* *random-state* *evalhook* *applyhook*
  36. + ++ +++ - * ** *** / // /// *standard-input* *standard-output* *error-output*
  37. *query-io* *debug-io* *terminal-io* *trace-output* *read-base* *read-suppress*
  38. *readtable* *print-escape* *print-pretty* *print-circle* *print-base*
  39. *print-radix* *print-case* *print-gensym* *print-level* *print-length*
  40. *print-array* *read-default-float-format* *default-pathname-defaults*
  41. *load-paths* *load-verbose* *load-print* *load-echo* *break-on-warnings*
  42. *features*
  43. ;; Funktionen:
  44. coerce type-of upgraded-array-element-type typep subtypep null symbolp
  45. atom consp listp numberp integerp rationalp floatp realp complexp characterp
  46. stringp bit-vector-p vectorp simple-vector-p simple-string-p
  47. simple-bit-vector-p arrayp packagep functionp compiled-function-p commonp eq
  48. eql equal equalp not symbol-value symbol-function boundp fboundp
  49. special-form-p set makunbound fmakunbound get-setf-method
  50. get-setf-method-multiple-value apply funcall mapcar maplist mapc mapl mapcan
  51. mapcon values values-list macro-function macroexpand macroexpand-1 proclaim
  52. get remprop symbol-plist getf get-properties symbol-name make-symbol
  53. copy-symbol gensym gentemp symbol-package keywordp make-package in-package
  54. find-package package-name package-nicknames rename-package package-use-list
  55. package-used-by-list package-shadowing-symbols list-all-packages intern
  56. find-symbol unintern export unexport import shadowing-import shadow
  57. use-package unuse-package find-all-symbols provide require zerop plusp minusp
  58. oddp evenp = /= < > <= >= max min + - * / 1+ 1- conjugate gcd lcm exp expt
  59. log sqrt isqrt abs phase signum sin cos tan cis asin acos atan sinh cosh tanh
  60. asinh acosh atanh float rational rationalize numerator denominator floor
  61. ceiling truncate round mod rem ffloor fceiling ftruncate fround decode-float
  62. scale-float float-radix float-sign float-digits float-precision
  63. integer-decode-float complex realpart imagpart logior logxor logand logeqv
  64. lognand lognor logandc1 logandc2 logorc1 logorc2 lognot logtest logbitp ash
  65. logcount integer-length byte byte-size byte-position ldb ldb-test mask-field
  66. dpb deposit-field random make-random-state random-state-p standard-char-p
  67. graphic-char-p string-char-p alpha-char-p upper-case-p lower-case-p
  68. both-case-p digit-char-p alphanumericp char= char/= char< char> char<= char>=
  69. char-equal char-not-equal char-lessp char-greaterp char-not-greaterp
  70. char-not-lessp char-code char-bits char-font code-char make-char character
  71. char-upcase char-downcase digit-char char-int int-char char-name name-char
  72. char-bit set-char-bit elt subseq copy-seq length reverse nreverse
  73. make-sequence concatenate map some every notany notevery reduce fill replace
  74. remove remove-if remove-if-not delete delete-if delete-if-not
  75. remove-duplicates delete-duplicates substitute substitute-if
  76. substitute-if-not nsubstitute nsubstitute-if nsubstitute-if-not find find-if
  77. find-if-not position position-if position-if-not count count-if count-if-not
  78. mismatch search sort stable-sort merge car cdr caar cadr cdar cddr caaar
  79. caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
  80. cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
  81. cons tree-equal endp list-length nth first second third fourth fifth sixth
  82. seventh eighth ninth tenth rest nthcdr last list list* make-list append
  83. copy-list copy-alist copy-tree revappend nconc nreconc butlast nbutlast ldiff
  84. rplaca rplacd subst subst-if subst-if-not nsubst nsubst-if-not sublis nsublis
  85. member member-if member-if-not tailp adjoin union nunion intersection
  86. nintersection set-difference nset-difference set-exclusive-or
  87. nset-exclusive-or subsetp acons pairlis assoc assoc-if assoc-if-not rassoc
  88. rassoc-if rassoc-if-not make-hash-table hash-table-p gethash remhash maphash
  89. clrhash hash-table-count sxhash make-array vector aref svref
  90. array-element-type array-rank array-dimension array-dimensions
  91. array-total-size array-in-bounds-p array-row-major-index adjustable-array-p
  92. bit sbit bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
  93. bit-orc1 bit-orc2 bit-not array-has-fill-pointer-p fill-pointer vector-push
  94. vector-push-extend vector-pop adjust-array char schar string= string-equal
  95. string< string> string<= string>= string/= string-lessp string-greaterp
  96. string-not-greaterp string-not-lessp string-not-equal make-string string-trim
  97. string-left-trim string-right-trim string-upcase string-downcase
  98. string-capitalize nstring-upcase nstring-downcase nstring-capitalize string
  99. eval evalhook applyhook constantp make-synonym-stream make-broadcast-stream
  100. make-concatenated-stream make-two-way-stream make-echo-stream
  101. make-string-input-stream make-string-output-stream get-output-stream-string
  102. streamp input-stream-p output-stream-p stream-element-type interactive-stream-p
  103. close copy-readtable readtablep set-syntax-from-char set-macro-character
  104. get-macro-character make-dispatch-macro-character
  105. set-dispatch-macro-character get-dispatch-macro-character read
  106. read-preserving-whitespace read-delimited-list read-line read-char
  107. unread-char peek-char listen read-char-no-hang clear-input read-from-string
  108. parse-integer read-byte write prin1 print pprint princ write-to-string
  109. prin1-to-string princ-to-string write-char write-string write-line terpri
  110. fresh-line finish-output force-output clear-output write-byte format y-or-n-p
  111. yes-or-no-p pathname truename parse-namestring merge-pathnames make-pathname
  112. pathnamep pathname-host pathname-device pathname-directory pathname-name
  113. pathname-type pathname-version namestring file-namestring
  114. directory-namestring host-namestring enough-namestring user-homedir-pathname
  115. open rename-file delete-file probe-file file-write-date file-author
  116. file-position file-length load directory error cerror warn break compile
  117. compile-file disassemble
  118. documentation  variable structure type ; drei Dokumentations-Typen
  119. describe inspect room ed dribble apropos apropos-list get-decoded-time
  120. get-universal-time decode-universal-time encode-universal-time
  121. get-internal-run-time get-internal-real-time sleep lisp-implementation-type
  122. lisp-implementation-version machine-type machine-version machine-instance
  123. software-type software-version short-site-name long-site-name identity
  124. ;; Special-forms:
  125. eval-when quote function setq progn let let* locally compiler-let progv flet
  126. labels macrolet if block return-from tagbody go multiple-value-call
  127. multiple-value-prog1 catch unwind-protect throw declare the load-time-value
  128. ;; Macros:
  129. deftype defun defvar defparameter defconstant and or psetq setf psetf shiftf
  130. rotatef define-modify-macro defsetf define-setf-method prog1 prog2
  131. when unless cond
  132. case typecase  otherwise ; otherwise als Marker für die catchall-clause
  133. return loop do do* dolist dotimes prog prog* multiple-value-list
  134. multiple-value-bind multiple-value-setq defmacro remf do-symbols
  135. do-external-symbols do-all-symbols incf decf push pushnew pop defstruct
  136. with-open-stream with-input-from-string with-output-to-string with-open-file
  137. check-type assert etypecase ctypecase ecase ccase trace untrace step time
  138. ;; sonstige Markierer:
  139. eval load compile ; EVAL-WHEN-Situationen
  140. special type ftype function inline notinline ignore optimize speed space
  141. safety compilation-speed debug declaration compile ; DECLARE-Specifier
  142. interpreter compiler ; Features
  143. ))
  144.  
  145. (sys::%proclaim-constant 'lambda-list-keywords
  146.   '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)
  147. )
  148. (export lambda-list-keywords)
  149.  
  150. (sys::%putd 'exit #'sys::%exit)
  151. (sys::%putd 'quit #'sys::%exit)
  152. (sys::%putd 'bye #'sys::%exit)
  153. (export '(exit quit bye))
  154.  
  155. (proclaim '(special *features*))
  156. ; Nach der Initialisierung (in IO.Q bzw. SPVW.D) enthält *features*
  157. ; als drittes Symbol  (first (sys::version)) = SYS::CLISP1/2/3
  158. ; und als letztes Symbol  (intern *language* "LISP").
  159. (import *features*)
  160. (export *features*)
  161.  
  162. (in-package "SYSTEM" :nicknames '("SYS" "COMPILER"))
  163. (setq compiler::*compiling* nil)
  164.  
  165. (in-package "CLOS" :use '("LISP"))
  166. ;;; Exportierungen:
  167. (export '(
  168.   ;; Namen von Funktionen und Macros:
  169.   slot-value slot-boundp slot-makunbound slot-exists-p with-slots with-accessors
  170.   find-class class-of defclass defmethod call-next-method next-method-p
  171.   defgeneric generic-function generic-flet generic-labels
  172.   class-name
  173.   no-applicable-method no-primary-method no-next-method
  174.   find-method add-method remove-method
  175.   compute-applicable-methods method-qualifiers function-keywords
  176.   slot-missing slot-unbound
  177.   print-object describe-object
  178.   make-instance initialize-instance reinitialize-instance shared-initialize
  179.   ;; Namen von Klassen:
  180.   standard-class structure-class built-in-class
  181.   standard-object standard-generic-function standard-method
  182.   ;; andere Symbole:
  183.   standard ; Methoden-Kombination
  184. ))
  185.  
  186. (in-package "SYSTEM")
  187.  
  188. #-COMPILER ; nur beim Bootstrappen
  189. (progn
  190.  
  191. ; vorläufig soll bei GET_CLOSURE nicht expandiert werden:
  192. (sys::%putd '%expand-lambdabody-main
  193.   (function %expand-lambdabody-main
  194.     (lambda (lambdabody venv fenv)
  195.       (declare (source nil) (ignore venv fenv))
  196.       lambdabody
  197. ) ) )
  198.  
  199. ; vorläufig soll defun ganz trivial expandiert werden:
  200. (sys::%putd 'defun
  201.   (cons 'sys::macro
  202.     (function defun
  203.       (lambda (form env)
  204.         (declare (ignore env))
  205.         #|
  206.         (let ((name (cadr form))
  207.               (lambdalist (caddr form))
  208.               (body (cdddr form)))
  209.           `(SYS::%PUTD ',name (FUNCTION ,name (LAMBDA ,lambdalist ,@body)))
  210.         )
  211.         |#
  212.         (let ((name (cadr form)))
  213.           (list 'sys::%putd (list 'quote name)
  214.             (list 'function name (cons 'lambda (cddr form)))
  215.         ) )
  216.     ) )
  217. ) )
  218.  
  219. )
  220.  
  221. (sys::%putd 'sys::remove-old-definitions
  222.   (function sys::remove-old-definitions
  223.     (lambda (symbol) ; entfernt die alten Funktionsdefinitionen eines Symbols
  224.       (if (special-form-p symbol)
  225.         (error #+DEUTSCH "~S ist eine Special-Form und darf nicht umdefiniert werden."
  226.                #+ENGLISH "~S is a special form and may not be redefined."
  227.                #+FRANCAIS "~S est une forme spéciale et ne peut pas être redéfinie."
  228.                symbol
  229.       ) )
  230.       (if (and (or (fboundp symbol) (macro-function symbol))
  231.                (let ((pack (symbol-package symbol)))
  232.                  (and pack (equal (package-name pack) "LISP"))
  233.           )    )
  234.         (cerror #+DEUTSCH "Die alte Definition wird weggeworfen."
  235.                 #+ENGLISH "The old definition will be lost"
  236.                 #+FRANCAIS "L'ancienne définition sera perdue."
  237.                 #+DEUTSCH "D~2@*~:[ie~;er~]~0@* COMMON-LISP-~A ~S wird umdefiniert."
  238.                 #+ENGLISH "Redefining the COMMON LISP ~A ~S"
  239.                 #+FRANCAIS "L~2@*~:[a~;e~]~0@* ~A ~S de COMMON-LISP va être redéfini~:[e~;~]."
  240.                 (fbound-string symbol) ; "Funktion" bzw. "Macro"
  241.                 symbol
  242.                 #+(or DEUTSCH FRANCAIS) (macro-function symbol)
  243.       ) )
  244.       (fmakunbound symbol) ; Funktions-/Macro-Definition streichen
  245.       ; Property sys::definition wird nicht entfernt, da sie sowieso
  246.       ; bald neu gesetzt wird.
  247.       (remprop symbol 'sys::macro) ; Macro-Definition streichen
  248.       (when (get symbol 'sys::documentation-strings) ; Dokumentation streichen
  249.         (sys::%set-documentation symbol 'FUNCTION nil)
  250.       )
  251.       (when (get symbol 'sys::inline-expansion)
  252.         (sys::%put symbol 'sys::inline-expansion t)
  253.       )
  254.       (when (get symbol 'sys::traced-definition) ; Trace streichen
  255.         (warn #+DEUTSCH "DEFUN/DEFMACRO: ~S war getraced und wird umdefiniert!"
  256.               #+ENGLISH "DEFUN/DEFMACRO: redefining ~S; it was traced!"
  257.               #+FRANCAIS "DEFUN/DEFMACRO : ~S était tracée et est redéfinie!"
  258.               symbol
  259.         )
  260.         (untrace2 symbol)
  261.     ) )
  262. ) )
  263.  
  264. ; liefert den Namen des impliziten Blocks zu einem Funktionsnamen
  265. (defun block-name (funname)
  266.   (if (atom funname) funname (second funname))
  267. )
  268.  
  269. ;;; Funktionen zum Expandieren von Macros innerhalb eines Codestückes
  270. ;;;
  271. ;;; Insgesamt wird der gesamte Code (einer Funktion) durchgegangen und
  272. ;;; globale und lokale Macros expandiert.
  273. ;;; Aus       #'(lambda lambdalist . body)
  274. ;;; wird so   #'(lambda expanded-lambdalist
  275. ;;;               (declare (source (lambdalist . body))) . expanded-body
  276. ;;;             )
  277. ;;; Durch diese Deklaration ist gewährleistet, daß eine bereits einmal
  278. ;;; durchlaufene Funktion als solche erkannt und nicht unnötigerweise ein
  279. ;;; zweites Mal durchlaufen wird.
  280.  
  281. ; Vorsicht! Fürs Bootstrappen (erkennbar an #-COMPILER) müssen manche der
  282. ; Funktionen in primitiverem Lisp (ohne do, do*, case) geschrieben werden.
  283.  
  284. (PROGN
  285.  
  286. (proclaim '(special *keyword-package*))
  287. (setq *keyword-package* (find-package "KEYWORD"))
  288.  
  289. (proclaim '(special *fenv*))
  290. ; *fenv* = Das aktuelle Function-Environment während der Expansion
  291. ; einer Form. Struktur: NIL oder ein 2n+1-elementiger Vektor
  292. ; (n1 f1 ... nn fn next), wo die ni Funktionsnamen sind, die fi ihre funktionale
  293. ; Bedeutung sind (Closure oder (MACRO . Closure) oder noch NIL); bei next
  294. ; geht's ebenso weiter.
  295.  
  296. ; (fenv-assoc s fenv) sucht Symbol s in Function-Environment fenv.
  297. (defun fenv-assoc (s fenv)
  298.   (if fenv
  299.     (if (simple-vector-p fenv)
  300.       #+COMPILER
  301.       (do ((l (1- (length fenv)))
  302.            (i 0 (+ i 2)))
  303.           ((= i l) (fenv-assoc s (svref fenv i)))
  304.         (if (equal s (svref fenv i))
  305.           (return (svref fenv (1+ i)))
  306.       ) )
  307.       #-COMPILER
  308.       (let ((l (1- (length fenv)))
  309.             (i 0))
  310.         (block nil
  311.           (tagbody
  312.             1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i))))
  313.               (if (equal s (svref fenv i))
  314.                 (return-from nil (svref fenv (1+ i)))
  315.               )
  316.               (setq i (+ i 2))
  317.               (go 1)
  318.       ) ) )
  319.       (error #+DEUTSCH "~S ist kein korrektes Function-Environment."
  320.              #+ENGLISH "~S is an invalid function environment"
  321.              #+FRANCAIS "~S n'est pas un environnement de fonctions correct."
  322.              fenv
  323.     ) )
  324.     'T ; nicht gefunden
  325. ) )
  326. ; Stellt fest, ob ein Funktionsname im Function-Environment fenv nicht
  327. ; definiert ist und daher auf die globale Funktion verweist.
  328. (defun global-in-fenv-p (s fenv) ; vorläufig
  329.   (eq (fenv-assoc s fenv) 'T)
  330. )
  331.  
  332. (proclaim '(special *venv*))
  333. ; *venv* = Das aktuelle Variablen-Environment während der Expansion
  334. ; einer Form. Struktur: NIL oder ein 2n+1-elementiger Vektor
  335. ; (n1 v1 ... nn vn next), wo die ni Symbole sind, die vi ihre
  336. ; syntaktische Bedeutung (Symbol-Macro-Objekt oder sonstiges); bei next
  337. ; geht's ebenso weiter.
  338.  
  339. ; (venv-assoc s venv) sucht Symbol s in Variablen-Environment venv.
  340. ; Liefert den Wert (oder NIL falls kein Wert).
  341. ; Vorsicht: Der Wert kann #<SPECDECL> oder #<SYMBOL-MACRO ...> sein, darf
  342. ; daher in interpretiertem Code nicht in einer Variablen zwischengespeichert
  343. ; werden.
  344. (defun venv-assoc (s venv)
  345.   (if venv
  346.     (if (simple-vector-p venv)
  347.       #+COMPILER
  348.       (do ((l (1- (length venv)))
  349.            (i 0 (+ i 2)))
  350.           ((= i l) (venv-assoc s (svref venv i)))
  351.         (if (eq s (svref venv i))
  352.           (return (svref venv (1+ i)))
  353.       ) )
  354.       #-COMPILER
  355.       (let ((l (1- (length venv)))
  356.             (i 0))
  357.         (block nil
  358.           (tagbody
  359.             1 (if (= i l) (return-from nil (venv-assoc s (svref venv i))))
  360.               (if (eq s (svref venv i))
  361.                 (return-from nil (svref venv (1+ i)))
  362.               )
  363.               (setq i (+ i 2))
  364.               (go 1)
  365.       ) ) )
  366.       (error #+DEUTSCH "~S ist kein korrektes Variablen-Environment."
  367.              #+ENGLISH "~S is an invalid variable environment"
  368.              #+FRANCAIS "~S n'est pas un environnement de variables correct."
  369.              venv
  370.     ) )
  371.     (and (boundp s) (symbol-value s)) ; nicht gefunden
  372. ) )
  373.  
  374. ; Die meisten Expansionsfunktionen liefern zwei Werte: Das Expansions-
  375. ; ergebnis, der zweite Wert (NIL oder T) zeigt an, ob darin etwas verändert
  376. ; wurde.
  377.  
  378. ; (%expand-cons ...) setzt ein cons zusammen. 2 Werte.
  379. ; form=alte Form,
  380. ; expf,flagf = Expansion des First-Teils,
  381. ; expr,flagr = Expansion des Rest-Teils.
  382. (defun %expand-cons (form expf flagf expr flagr)
  383.   (if (or flagf flagr)
  384.     (values (cons expf expr) t)
  385.     (values form nil)
  386. ) )
  387.  
  388. #+COMPILER
  389.  
  390. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  391. (defun %expand-form (form)
  392.   (if (atom form)
  393.     (let (h)
  394.       (if (and (symbolp form) (symbol-macro-p (setq h (venv-assoc form *venv*))))
  395.         (values (sys::%record-ref h 0) t)
  396.         (values form nil)
  397.     ) )
  398.     ; form ist CONS
  399.     (let ((f (first form)))
  400.       (if (function-name-p f)
  401.         (let ((h (fenv-assoc f *fenv*)))
  402.           ; f ist in *fenv* assoziiert zu h
  403.           (if (eq h 'T)
  404.             ; f hat keine lokale Definition
  405.             ; Nun die einzelnen Expander für die Special-forms:
  406.             (case f
  407.               ((RETURN-FROM THE)
  408.                 ; 1. Argument lassen, alle weiteren expandieren
  409.                 (multiple-value-call #'%expand-cons form
  410.                   (first form) nil
  411.                   (multiple-value-call #'%expand-cons (rest form)
  412.                     (second form) nil
  413.                     (%expand-list (cddr form))
  414.               ) ) )
  415.               ((QUOTE GO DECLARE LOAD-TIME-VALUE) ; nichts expandieren
  416.                 (values form nil)
  417.               )
  418.               (FUNCTION
  419.                 ; Falls erstes bzw. zweites Argument Liste,
  420.                 ; als Lambda-Ausdruck expandieren.
  421.                 (multiple-value-call #'%expand-cons form
  422.                   'FUNCTION nil
  423.                   (if (atom (cddr form))
  424.                     (if (function-name-p (second form))
  425.                       (let ((h (fenv-assoc (second form) *fenv*)))
  426.                         (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  427.                               ((and (consp h) (eq (first h) 'MACRO))
  428.                                (error #+DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  429.                                       #+ENGLISH "~S: ~S is illegal since ~S is a local macro"
  430.                                       #+FRANCAIS "~S : ~S est illégal car ~S est un macro local"
  431.                                       '%expand form (second form)
  432.                               ))
  433.                               (t (error #+DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  434.                                         #+ENGLISH "~S: invalid function environment ~S"
  435.                                         #+FRANCAIS "~S : mauvais environnement de fonction ~S"
  436.                                         '%expand *fenv*
  437.                               )  )
  438.                       ) )
  439.                       (if (atom (second form))
  440.                         (error #+DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  441.                                #+ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  442.                                #+FRANCAIS "~S : ~S est illégal car ~S n'est pas un symbole"
  443.                                '%expand form (second form)
  444.                         )
  445.                         (multiple-value-call #'%expand-cons (rest form)
  446.                           (%expand-lambda (second form))
  447.                           (cddr form) nil
  448.                     ) ) )
  449.                     (multiple-value-call #'%expand-cons (rest form)
  450.                       (second form) nil
  451.                       (multiple-value-call #'%expand-cons (cddr form)
  452.                         (%expand-lambda (third form))
  453.                         (cdddr form) nil
  454.               ) ) ) ) )
  455.               (EVAL-WHEN
  456.                 ; Falls die Situation COMPILE angegeben ist, führe den Body
  457.                 ; als PROGN aus, gib eine Form zurück, die ohne Seiteneffekte
  458.                 ; dieselben Werte liefert.
  459.                 ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  460.                 (if (member 'COMPILE (second form))
  461.                   (values
  462.                     (list 'values-list
  463.                       (list 'quote
  464.                         (multiple-value-list (eval (cons 'PROGN (cddr form))))
  465.                     ) )
  466.                     t
  467.                   )
  468.                   (multiple-value-call #'%expand-cons form
  469.                     (first form) nil
  470.                     (multiple-value-call #'%expand-cons (rest form)
  471.                       (second form) nil
  472.                       (%expand-list (cddr form))
  473.               ) ) ) )
  474.               (LET ; Variablenliste und Body expandieren
  475.                 (let ((*venv* *venv*))
  476.                   (%expand-special-declarations (cddr form))
  477.                   (multiple-value-call #'%expand-cons form
  478.                     (first form) nil
  479.                     (multiple-value-call #'%expand-cons (rest form)
  480.                       (%expand-varspez (second form))
  481.                       (%expand-list (cddr form))
  482.               ) ) ) )
  483.               (LET* ; Variablenliste und Body expandieren
  484.                 (let ((*venv* *venv*))
  485.                   (%expand-special-declarations (cddr form))
  486.                   (multiple-value-call #'%expand-cons form
  487.                     (first form) nil
  488.                     (multiple-value-call #'%expand-cons (rest form)
  489.                       (%expand-varspez* (second form))
  490.                       (%expand-list (cddr form))
  491.               ) ) ) )
  492.               (LOCALLY ; Body expandieren
  493.                 (let ((*venv* *venv*))
  494.                   (%expand-special-declarations (cdr form))
  495.                   (multiple-value-call #'%expand-cons form
  496.                     (first form) nil
  497.                     (%expand-list (cdr form))
  498.               ) ) )
  499.               (MULTIPLE-VALUE-BIND ; Form und Body getrennt expandieren
  500.                 (let ((*venv* *venv*))
  501.                   (%expand-special-declarations (cdddr form))
  502.                   (multiple-value-call #'%expand-cons form
  503.                     'MULTIPLE-VALUE-BIND nil
  504.                     (multiple-value-call #'%expand-cons (rest form)
  505.                       (second form) nil
  506.                       (multiple-value-call #'%expand-cons (cddr form)
  507.                         (%expand-form (third form))
  508.                         (progn
  509.                           (%expand-lexical-variables (second form))
  510.                           (%expand-list (cdddr form))
  511.               ) ) ) ) ) )
  512.               (COMPILER-LET
  513.                 ; Variablenliste im leeren Environment und Body expandieren
  514.                 (progv
  515.                   (mapcar #'%expand-varspec-var (second form))
  516.                   (mapcar #'%expand-varspec-val (second form))
  517.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  518.               ) )
  519.               (COND ; Alle Teilformen der Klauseln expandieren:
  520.                 (multiple-value-call #'%expand-cons form
  521.                   (first form) nil
  522.                   (%expand-cond (rest form))
  523.               ) )
  524.               (BLOCK
  525.                 ; Body expandieren. Falls darin ein RETURN-FROM auf diesen
  526.                 ; Block vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  527.                 (multiple-value-bind (body flagb) (%expand-list (cddr form))
  528.                   (if (%return-p (second form) body)
  529.                     (multiple-value-call #'%expand-cons form
  530.                       (first form) nil
  531.                       (multiple-value-call #'%expand-cons (rest form)
  532.                         (second form) nil
  533.                         body flagb
  534.                     ) )
  535.                     (values
  536.                       (cond ((atom body) body)
  537.                             ((null (cdr body)) (car body))
  538.                             (t (cons 'progn body))
  539.                       )
  540.                       t
  541.               ) ) ) )
  542.               ((SETQ PSETQ) ; jedes zweite Argument expandieren
  543.                 (if (%expand-setqlist-macrop (rest form))
  544.                   (let ((new (if (eq (first form) 'SETQ) 'SETF 'PSETF)))
  545.                     (values
  546.                       (%expand-form
  547.                         (funcall (macro-function new) (cons new (rest form)) (vector *venv* *fenv*))
  548.                       )
  549.                       t
  550.                   ) )
  551.                   (multiple-value-call #'%expand-cons form
  552.                     (first form) nil
  553.                     (%expand-setqlist (rest form))
  554.               ) ) )
  555.               (MULTIPLE-VALUE-SETQ ; 1. Argument lassen, alle weiteren expandieren
  556.                 (if (%expand-varlist-macrop (second form))
  557.                   (values (%expand-form (cons 'MULTIPLE-VALUE-SETF (rest form))) t)
  558.                   (multiple-value-call #'%expand-cons form
  559.                     'MULTIPLE-VALUE-SETQ nil
  560.                     (multiple-value-call #'%expand-cons (rest form)
  561.                       (second form) nil
  562.                       (%expand-list (cddr form))
  563.               ) ) ) )
  564.               (TAGBODY
  565.                 ; alle Argumente expandieren, dabei entstehende Atome weglassen
  566.                 (multiple-value-call #'%expand-cons form
  567.                   (first form) nil
  568.                   (%expand-tagbody (rest form))
  569.               ) )
  570.               (PROGN ; alle Argumente expandieren, evtl. vereinfachen.
  571.                 (if (null (rest form))
  572.                   (values nil t)
  573.                   (if (null (cddr form))
  574.                     (values (%expand-form (second form)) t)
  575.                     (multiple-value-call #'%expand-cons form
  576.                       (first form) nil
  577.                       (%expand-list (rest form))
  578.               ) ) ) )
  579.               (FLET ; Funktionsdefinitionen expandieren,
  580.                     ; Body im erweiterten Environment expandieren
  581.                 (if (null (second form))
  582.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  583.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  584.                     (multiple-value-call #'%expand-cons form
  585.                       (first form) nil
  586.                       (multiple-value-call #'%expand-cons (rest form)
  587.                         (%expand-fundefs-2 (second form))
  588.                         (let ((*fenv* (apply #'vector newfenv)))
  589.                           (%expand-list (cddr form))
  590.               ) ) ) ) ) )
  591.               (LABELS ; Funktionsdefinitionen und Body im erweiterten Environment expandieren
  592.                 (if (null (second form))
  593.                   (values (%expand-form (cons 'PROGN (cddr form))) t)
  594.                   (let ((newfenv (%expand-fundefs-1 (second form))))
  595.                     (let ((*fenv* (apply #'vector newfenv)))
  596.                       (multiple-value-call #'%expand-cons form
  597.                         (first form) nil
  598.                         (multiple-value-call #'%expand-cons (rest form)
  599.                           (%expand-fundefs-2 (second form))
  600.                           (%expand-list (cddr form))
  601.               ) ) ) ) ) )
  602.               (MACROLET ; Body im erweiterten Environment expandieren
  603.                 (do ((L1 (second form) (cdr L1))
  604.                      (L2 nil))
  605.                     ((atom L1)
  606.                      (if L1
  607.                        (error #+DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  608.                               #+ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  609.                               #+FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  610.                               L1
  611.                        )
  612.                        (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  613.                          (values (%expand-form (cons 'PROGN (cddr form))) t)
  614.                     )) )
  615.                   (let ((macrodef (car L1)))
  616.                     (if (and (consp macrodef)
  617.                              (symbolp (car macrodef))
  618.                              (consp (cdr macrodef))
  619.                         )
  620.                       (setq L2
  621.                         (cons (make-macro-expandercons macrodef)
  622.                               (cons (car macrodef) L2)
  623.                       ) )
  624.                       (error #+DEUTSCH "Falsche Syntax in MACROLET: ~S"
  625.                              #+ENGLISH "illegal syntax in MACROLET: ~S"
  626.                              #+FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  627.                              macrodef
  628.               ) ) ) ) )
  629.               (SYMBOL-MACROLET ; Body im erweiterten Environment expandieren
  630.                 (do ((L1 (second form) (cdr L1))
  631.                      (L2 nil))
  632.                     ((atom L1)
  633.                      (if L1
  634.                        (error #+DEUTSCH "Dotted list im Code von SYMBOL-MACROLET, endet mit ~S"
  635.                               #+ENGLISH "code after SYMBOL-MACROLET contains a dotted list, ending with ~S"
  636.                               #+FRANCAIS "Le code de SYMBOL-MACROLET contient une paire pointée, terminée par ~S"
  637.                               L1
  638.                        )
  639.                        (let ((*venv* (apply #'vector (nreverse (cons *venv* L2)))))
  640.                          (values (%expand-form (cons 'LOCALLY (cddr form))) t)
  641.                     )) )
  642.                   (let ((symdef (car L1)))
  643.                     (if (and (consp symdef)
  644.                              (symbolp (car symdef))
  645.                              (consp (cdr symdef))
  646.                              (null (cddr symdef))
  647.                         )
  648.                       (setq L2
  649.                         (cons (make-symbol-macro (cadr symdef)) (cons (car symdef) L2))
  650.                       )
  651.                       (error #+DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  652.                              #+ENGLISH "illegal syntax in SYMBOL-MACROLET: ~S"
  653.                              #+FRANCAIS "syntaxe illégale dans SYMBOL-MACROLET : ~S"
  654.                              symdef
  655.               ) ) ) ) )
  656.               (t
  657.                 (cond ((and (symbolp f) (special-form-p f))
  658.                        ; sonstige Special-forms,
  659.                        ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  660.                        ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  661.                        ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  662.                        (multiple-value-call #'%expand-cons form
  663.                          f nil
  664.                          (%expand-list (rest form))
  665.                       ))
  666.                       ((and (symbolp f) (setq h (macro-function f))) ; globale Macro-Definition
  667.                        (values (%expand-form (funcall h form (vector *venv* *fenv*))) t)
  668.                       )
  669.                       (t ; normaler Funktionsaufruf
  670.                        (multiple-value-call #'%expand-cons form
  671.                          f nil
  672.                          (%expand-list (rest form))
  673.             ) ) )     ))
  674.             ; f hat eine lokale Definition
  675.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  676.                    (multiple-value-call #'%expand-cons form
  677.                      f nil
  678.                      (%expand-list (rest form))
  679.                   ))
  680.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  681.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  682.                   ) ; Expander aufrufen
  683.                   (t (error #+DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  684.                             #+ENGLISH "bad function environment occurred in ~S: ~S"
  685.                             #+FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  686.                             '%expand-form *fenv*
  687.         ) ) )     )  )
  688.         (if (consp f)
  689.           (multiple-value-call #'%expand-cons form
  690.             (%expand-lambda f)
  691.             (%expand-list (rest form))
  692.           )
  693.           (error #+DEUTSCH "~S: ~S ist keine korrekte Form"
  694.                  #+ENGLISH "~S: invalid form ~S"
  695.                  #+FRANCAIS "~S : forme Lisp incorrecte ~S"
  696.                  '%expand-form form
  697. ) ) ) ) ) )
  698.  
  699. #-COMPILER
  700. (progn
  701.  
  702. ; (%expand-form form) expandiert eine ganze Form. 2 Werte.
  703. (defun %expand-form (form)
  704.   (if (atom form)
  705.     (let (h)
  706.       (if (and (symbolp form) (symbol-macro-p (setq h (venv-assoc form *venv*))))
  707.         (values (sys::%record-ref h 0) t)
  708.         (values form nil)
  709.     ) )
  710.     ; form ist CONS
  711.     (let ((f (first form)))
  712.       (if (function-name-p f)
  713.         (let ((h (fenv-assoc f *fenv*)))
  714.           ; f ist in *fenv* assoziiert zu h
  715.           (if (eq h 'T)
  716.             ; f hat keine lokale Definition
  717.             (cond ((setq h (get '%expand f)) ; special forms u.ä.
  718.                    (funcall h form)
  719.                   )
  720.                   ((and (symbolp f) (special-form-p f))
  721.                    ; sonstige Special-forms,
  722.                    ; z.B. IF, CATCH, THROW, PROGV, UNWIND-PROTECT, PROGN,
  723.                    ; PROG1, PROG2, WHEN, UNLESS, MULTIPLE-VALUE-LIST,
  724.                    ; MULTIPLE-VALUE-CALL, MULTIPLE-VALUE-PROG1, AND, OR:
  725.                    (multiple-value-call #'%expand-cons form
  726.                      f nil
  727.                      (%expand-list (rest form))
  728.                   ))
  729.                   ((and (symbolp f) (setq h (macro-function f))) ; globale Macro-Definition
  730.                    (values (%expand-form (funcall h form (vector *venv* *fenv*))) t)
  731.                   )
  732.                   (t ; normaler Funktionsaufruf
  733.                    (multiple-value-call #'%expand-cons form
  734.                      f nil
  735.                      (%expand-list (rest form))
  736.             )     ))
  737.             ; f hat eine lokale Definition
  738.             (cond ((or (closurep h) (null h)); aufzurufende Funktion
  739.                    (multiple-value-call #'%expand-cons form
  740.                      f nil
  741.                      (%expand-list (rest form))
  742.                   ))
  743.                   ((and (consp h) (eq (car h) 'MACRO)) ; zu expandierender Macro
  744.                    (values (%expand-form (funcall (cdr h) form *fenv*)) t)
  745.                   ) ; Expander aufrufen
  746.                   (t (error #+DEUTSCH "Falscher Aufbau eines Function-Environment in ~S: ~S"
  747.                             #+ENGLISH "bad function environment occurred in ~S: ~S"
  748.                             #+FRANCAIS "mauvais environnement de fonction dans ~S : ~S"
  749.                             '%expand-form *fenv*
  750.         ) ) )     )  )
  751.         (if (consp f)
  752.           (multiple-value-call #'%expand-cons form
  753.             (%expand-lambda f)
  754.             (%expand-list (rest form))
  755.           )
  756.           (error #+DEUTSCH "~S: ~S ist keine korrekte Form"
  757.                  #+ENGLISH "~S: invalid form ~S"
  758.                  #+FRANCAIS "~ : forme Lisp incorrecte ~S"
  759.                  '%expand-form form
  760. ) ) ) ) ) )
  761.  
  762. ; Nun die einzelnen Expander für die Special-forms:
  763.  
  764. ; RETURN-FROM, THE:
  765. ; 1. Argument lassen, alle weiteren expandieren
  766. (defun %expand-ab2 (form)
  767.   (multiple-value-call #'%expand-cons form
  768.       (first form) nil
  769.       (multiple-value-call #'%expand-cons (rest form)
  770.           (second form) nil
  771.           (%expand-list (cddr form))
  772. ) )   )
  773. (%put '%expand 'RETURN-FROM #'%expand-ab2)
  774. (%put '%expand 'THE #'%expand-ab2)
  775.  
  776. ; QUOTE, GO, DECLARE, LOAD-TIME-VALUE: nichts expandieren
  777. (let ((fun
  778.         (function %expand-quote/go/declare (lambda (form) (values form nil)))
  779.      ))
  780.   (%put '%expand 'QUOTE fun)
  781.   (%put '%expand 'GO fun)
  782.   (%put '%expand 'DECLARE fun)
  783.   (%put '%expand 'LOAD-TIME-VALUE fun)
  784. )
  785.  
  786. ; FUNCTION:
  787. ; Falls erstes bzw. zweites Argument Liste, als Lambda-Ausdruck expandieren.
  788. (%put '%expand 'FUNCTION
  789.   (function %expand-function
  790.     (lambda (form)
  791.       (multiple-value-call #'%expand-cons form
  792.           'FUNCTION nil
  793.           (if (atom (cddr form))
  794.             (if (function-name-p (second form))
  795.               (let ((h (fenv-assoc (second form) *fenv*)))
  796.                 (cond ((or (eq h 'T) (closurep h) (null h)) (values (rest form) nil))
  797.                       ((and (consp h) (eq (first h) 'MACRO))
  798.                        (error #+DEUTSCH "~S: ~S unzulässig, da ~S ein lokaler Macro ist"
  799.                               #+ENGLISH "~S: ~S is illegal since ~S is a local macro"
  800.                               #+FRANCAIS "~S : n'est pas permis car ~S est un macro local"
  801.                               '%expand form (second form)
  802.                       ))
  803.                       (t (error #+DEUTSCH "~S: Falscher Aufbau eines Function-Environment: ~S"
  804.                                 #+ENGLISH "~S: invalid function environment ~S"
  805.                                 #+FRANCAIS "~S : mauvais environnement de fonction ~S"
  806.                                 '%expand *fenv*
  807.                       )  )
  808.               ) )
  809.               (if (atom (second form))
  810.                 (error #+DEUTSCH "~S: ~S unzulässig, da ~S kein Symbol"
  811.                        #+ENGLISH "~S: ~S is invalid since ~S is not a symbol"
  812.                        #+FRANCAIS "~S : ~S est inadmissible car ~S n'est pas un symbole"
  813.                        '%expand form (second form)
  814.                 )
  815.                 (multiple-value-call #'%expand-cons (rest form)
  816.                     (%expand-lambda (second form))
  817.                     (cddr form) nil
  818.             ) ) )
  819.             (multiple-value-call #'%expand-cons (rest form)
  820.                 (second form) nil
  821.                 (multiple-value-call #'%expand-cons (cddr form)
  822.                     (%expand-lambda (third form))
  823.                     (cdddr form) nil
  824.   ) ) )   ) )   )
  825. )
  826.  
  827. ; EVAL-WHEN:
  828. ; Falls die Situation COMPILE angegeben ist, führe den Body als PROGN aus,
  829. ;   gib eine Form zurück, die ohne Seiteneffekte dieselben Werte liefert.
  830. ; Sonst expandiere alle Argumente ab dem zweiten als Formen.
  831. (%put '%expand 'EVAL-WHEN
  832.   (function %expand-eval-when
  833.     (lambda (form)
  834.       (if (member 'COMPILE (second form))
  835.         (values
  836.           (list 'values-list
  837.             (list 'quote
  838.               (multiple-value-list (eval (cons 'PROGN (cddr form))))
  839.           ) )
  840.           t
  841.         )
  842.         (%expand-ab2 form)
  843.   ) ) )
  844. )
  845.  
  846. ; LET: Variablenliste und Body expandieren
  847. (%put '%expand 'LET
  848.   (function %expand-let
  849.     (lambda (form)
  850.       (let ((*venv* *venv*))
  851.         (%expand-special-declarations (cddr form))
  852.         (multiple-value-call #'%expand-cons form
  853.           (first form) nil
  854.           (multiple-value-call #'%expand-cons (rest form)
  855.             (%expand-varspez (second form))
  856.             (%expand-list (cddr form))
  857.   ) ) ) ) )
  858. )
  859.  
  860. ; LET*: Variablenliste und Body expandieren
  861. (%put '%expand 'LET*
  862.   (function %expand-let*
  863.     (lambda (form)
  864.       (let ((*venv* *venv*))
  865.         (%expand-special-declarations (cddr form))
  866.         (multiple-value-call #'%expand-cons form
  867.           (first form) nil
  868.           (multiple-value-call #'%expand-cons (rest form)
  869.             (%expand-varspez* (second form))
  870.             (%expand-list (cddr form))
  871.   ) ) ) ) )
  872. )
  873.  
  874. ; LOCALLY: Body expandieren
  875. (%put '%expand 'LOCALLY
  876.   (function %expand-locally
  877.     (lambda (form)
  878.       (let ((*venv* *venv*))
  879.         (%expand-special-declarations (cdr form))
  880.         (multiple-value-call #'%expand-cons form
  881.           (first form) nil
  882.           (%expand-list (cdr form))
  883.   ) ) ) )
  884. )
  885.  
  886. ; MULTIPLE-VALUE-BIND: Form und Body getrennt expandieren
  887. (%put '%expand 'MULTIPLE-VALUE-BIND
  888.   (function %expand-multiple-value-bind
  889.     (lambda (form)
  890.       (let ((*venv* *venv*))
  891.         (%expand-special-declarations (cdddr form))
  892.         (multiple-value-call #'%expand-cons form
  893.           'MULTIPLE-VALUE-BIND nil
  894.           (multiple-value-call #'%expand-cons (rest form)
  895.             (second form) nil
  896.             (multiple-value-call #'%expand-cons (cddr form)
  897.               (%expand-form (third form))
  898.               (progn
  899.                 (%expand-lexical-variables (second form))
  900.                 (%expand-list (cdddr form))
  901.   ) ) ) ) ) ) )
  902. )
  903.  
  904. ; COMPILER-LET: Variablenliste im leeren Environment und Body expandieren
  905. (%put '%expand 'COMPILER-LET
  906.   (function %expand-compiler-let
  907.     (lambda (form)
  908.       (progv
  909.         (mapcar #'%expand-varspec-var (second form))
  910.         (mapcar #'%expand-varspec-val (second form))
  911.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  912.   ) ) )
  913. )
  914.  
  915. ; COND: Alle Teilformen der Klauseln expandieren:
  916. (%put '%expand 'cond
  917.   (function %expand-cond
  918.     (lambda (form)
  919.       (multiple-value-call #'%expand-cons form
  920.           (first form) nil
  921.           (%expand-cond (rest form))
  922.   ) ) )
  923. )
  924.  
  925. ; BLOCK: Body expandieren. Falls darin ein RETURN-FROM auf diesen Block
  926. ; vorkommt, behalte BLOCK. Sonst mache ein PROGN daraus.
  927. (%put '%expand 'block
  928.   (function %expand-block
  929.     (lambda (form)
  930.       (multiple-value-bind (body flagb) (%expand-list (cddr form))
  931.         (if (%return-p (second form) body)
  932.           (multiple-value-call #'%expand-cons form
  933.               (first form) nil
  934.               (multiple-value-call #'%expand-cons (rest form)
  935.                   (second form) nil
  936.                   body flagb
  937.           )   )
  938.           (values
  939.             (cond ((atom body) body)
  940.                   ((null (cdr body)) (car body))
  941.                   (t (cons 'progn body))
  942.             )
  943.             t
  944.   ) ) ) ) )
  945. )
  946.  
  947. ; SETQ, PSETQ: jedes zweite Argument expandieren
  948. (let ((fun
  949.         (function %expand-setq/psetq
  950.           (lambda (form)
  951.             (if (%expand-setqlist-macrop (rest form))
  952.               (let ((new (if (eq (first form) 'SETQ) 'SETF 'PSETF)))
  953.                 (values
  954.                   (%expand-form
  955.                     (funcall (macro-function new) (cons new (rest form)) (vector *venv* *fenv*))
  956.                   )
  957.                   t
  958.               ) )
  959.               (multiple-value-call #'%expand-cons form
  960.                 (first form) nil
  961.                 (%expand-setqlist (rest form))
  962.         ) ) ) )
  963.      ))
  964.   (%put '%expand 'SETQ fun)
  965.   (%put '%expand 'PSETQ fun)
  966. )
  967.  
  968. ; MULTIPLE-VALUE-SETQ : 1. Argument lassen, alle weiteren expandieren
  969. (%put '%expand 'multiple-value-setq
  970.   (function %expand-multiple-value-setq
  971.     (lambda (form)
  972.       (if (%expand-varlist-macrop (second form))
  973.         (values (%expand-form (cons 'MULTIPLE-VALUE-SETF (rest form))) t)
  974.         (%expand-ab2 form)
  975.   ) ) )
  976. )
  977.  
  978. ; TAGBODY: alle Argumente expandieren, dabei entstehende Atome weglassen
  979. (%put '%expand 'tagbody
  980.   (function %expand-tagbody
  981.     (lambda (form)
  982.       (multiple-value-call #'%expand-cons form
  983.           (first form) nil
  984.           (%expand-tagbody (rest form))
  985.   ) ) )
  986. )
  987.  
  988. ; PROGN: alle Argumente expandieren, evtl. vereinfachen.
  989. (%put '%expand 'progn
  990.   (function %expand-progn
  991.     (lambda (form)
  992.       (if (null (rest form))
  993.         (values nil t)
  994.         (if (null (cddr form))
  995.           (values (%expand-form (second form)) t)
  996.           (multiple-value-call #'%expand-cons form
  997.               (first form) nil
  998.               (%expand-list (rest form))
  999.   ) ) ) ) )
  1000. )
  1001.  
  1002. ; FLET: Funktionsdefinitionen expandieren,
  1003. ; Body im erweiterten Environment expandieren
  1004. (%put '%expand 'flet
  1005.   (function %expand-flet
  1006.     (lambda (form)
  1007.       (if (null (second form))
  1008.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  1009.         (let ((newfenv (%expand-fundefs-1 (second form))))
  1010.           (multiple-value-call #'%expand-cons form
  1011.             (car form) nil
  1012.             (multiple-value-call #'%expand-cons (cdr form)
  1013.               (%expand-fundefs-2 (second form))
  1014.               (let ((*fenv* (apply #'vector newfenv)))
  1015.                 (%expand-list (cddr form))
  1016.   ) ) ) ) ) ) )
  1017. )
  1018.  
  1019. ; LABELS: Funktionsdefinitionen und Body im erweiterten Environment expandieren
  1020. (%put '%expand 'labels
  1021.   (function %expand-labels
  1022.     (lambda (form)
  1023.       (if (null (second form))
  1024.         (values (%expand-form (cons 'PROGN (cddr form))) t)
  1025.         (let ((newfenv (%expand-fundefs-1 (second form))))
  1026.           (let ((*fenv* (apply #'vector newfenv)))
  1027.             (multiple-value-call #'%expand-cons form
  1028.               (car form) nil
  1029.               (multiple-value-call #'%expand-cons (cdr form)
  1030.                 (%expand-fundefs-2 (second form))
  1031.                 (%expand-list (cddr form))
  1032.   ) ) ) ) ) ) )
  1033. )
  1034.  
  1035. ; MACROLET: Body im erweiterten Environment expandieren
  1036. (%put '%expand 'macrolet
  1037.   (function %expand-macrolet
  1038.     (lambda (form)
  1039.       (do ((L1 (second form) (cdr L1))
  1040.            (L2 nil))
  1041.           ((atom L1)
  1042.            (if L1
  1043.              (error #+DEUTSCH "Dotted list im Code von MACROLET, endet mit ~S"
  1044.                     #+ENGLISH "code after MACROLET contains a dotted list, ending with ~S"
  1045.                     #+FRANCAIS "Le code de MACROLET contient une paire pointée, terminée par ~S"
  1046.                     L1
  1047.              )
  1048.              (let ((*fenv* (apply #'vector (nreverse (cons *fenv* L2)))))
  1049.                (values (%expand-form (cons 'PROGN (cddr form))) t)
  1050.           )) )
  1051.         (let ((macrodef (car L1)))
  1052.           (if (and (consp macrodef) (symbolp (car macrodef)) (consp (cdr macrodef)))
  1053.             (setq L2
  1054.               (cons (make-macro-expandercons macrodef)
  1055.                     (cons (car macrodef) L2)
  1056.             ) )
  1057.             (error #+DEUTSCH "Falsche Syntax in MACROLET: ~S"
  1058.                    #+ENGLISH "illegal syntax in MACROLET: ~S"
  1059.                    #+FRANCAIS "syntaxe illégale dans MACROLET : ~S"
  1060.                    macrodef
  1061.   ) ) ) ) ) )
  1062. )
  1063.  
  1064. ; SYMBOL-MACROLET: Body im erweiterten Environment expandieren
  1065. (%put '%expand 'symbol-macrolet
  1066.   (function %expand-symbol-macrolet
  1067.     (lambda (form)
  1068.       (do ((L1 (second form) (cdr L1))
  1069.            (L2 nil))
  1070.           ((atom L1)
  1071.            (if L1
  1072.              (error #+DEUTSCH "Dotted list im Code von SYMBOL-MACROLET, endet mit ~S"
  1073.                     #+ENGLISH "code after SYMBOL-MACROLET contains a dotted list, ending with ~S"
  1074.                     #+FRANCAIS "Le code de SYMBOL-MACROLET contient une paire pointée, terminée par ~S"
  1075.                     L1
  1076.              )
  1077.              (let ((*venv* (apply #'vector (nreverse (cons *venv* L2)))))
  1078.                (values (%expand-form (cons 'LOCALLY (cddr form))) t)
  1079.           )) )
  1080.         (let ((symdef (car L1)))
  1081.           (if (and (consp symdef)
  1082.                    (symbolp (car symdef))
  1083.                    (consp (cdr symdef))
  1084.                    (null (cddr symdef))
  1085.               )
  1086.             (setq L2
  1087.               (cons (make-symbol-macro (cadr symdef)) (cons (car symdef) L2))
  1088.             )
  1089.             (error #+DEUTSCH "Falsche Syntax in SYMBOL-MACROLET: ~S"
  1090.                    #+ENGLISH "illegal syntax in SYMBOL-MACROLET: ~S"
  1091.                    #+FRANCAIS "syntaxe illégale dans SYMBOL-MACROLET : ~S"
  1092.                    symdef
  1093.   ) ) ) ) ) )
  1094. )
  1095.  
  1096. )
  1097.  
  1098. ; Hilfsfunktionen für die Expansion:
  1099.  
  1100. ; expandiert eine Liste von Formen. 2 Werte.
  1101. (defun %expand-list (l)
  1102.   (if (atom l)
  1103.     (if l
  1104.       (error #+DEUTSCH "Dotted list im Code, endet mit ~S"
  1105.              #+ENGLISH "code contains a dotted list, ending with ~S"
  1106.              #+FRANCAIS "une paire pointée dans le code, terminée par ~S"
  1107.              l
  1108.       )
  1109.       (values nil nil)
  1110.     )
  1111.     (multiple-value-call #'%expand-cons l
  1112.                          (%expand-form (first l))
  1113.                          (%expand-list (rest l))
  1114. ) ) )
  1115.  
  1116. ; Fügt lexikalische Variablen zu *venv* hinzu.
  1117. ; (Wird nur dazu benutzt, um Symbol-Macros zu überdecken.)
  1118. (defun %expand-lexical-variables (vars)
  1119.   (if vars
  1120.     (setq *venv*
  1121.       (apply #'vector
  1122.         (nconc (mapcan #'(lambda (v) (list v nil)) vars) (list *venv*))
  1123. ) ) ) )
  1124.  
  1125. ; Fügt SPECIAL-Deklarationen am Anfang eines Body zu *venv* hinzu.
  1126. (defun %expand-special-declarations (body)
  1127.   (multiple-value-bind (body-rest declarations)
  1128.       (sys::parse-body body nil (vector *venv* *fenv*))
  1129.     (declare (ignore body-rest)) ; Deklarationen nicht wegwerfen!
  1130.     (let ((specials nil))
  1131.       (mapc #'(lambda (declspec)
  1132.                 (if (and (consp declspec) (null (cdr (last declspec))))
  1133.                   (if (eq (car declspec) 'SPECIAL)
  1134.                     (mapc #'(lambda (x) (if (symbolp x) (setq specials (cons x specials))))
  1135.                           (cdr declspec)
  1136.               ) ) ) )
  1137.             (nreverse declarations)
  1138.       )
  1139.       (%expand-lexical-variables (nreverse specials)) ; auf specdecl kommt es hier nicht an
  1140. ) ) )
  1141.  
  1142. ; expandiert einen Funktionsnamen, der ein Cons ist (das muß ein
  1143. ; Lambda-Ausdruck sein). 2 Werte.
  1144. (defun %expand-lambda (l)
  1145.   (unless (eq (first l) 'lambda)
  1146.     (error #+DEUTSCH "~S: ~S sollte LAMBDA-Ausdruck sein"
  1147.            #+ENGLISH "~S: ~S should be a lambda expression"
  1148.            #+FRANCAIS "~S : ~S devrait être une expression LAMBDA"
  1149.            '%expand-form l
  1150.   ) )
  1151.   (multiple-value-call #'%expand-cons l
  1152.       'lambda nil ; LAMBDA
  1153.       (%expand-lambdabody (rest l))
  1154. ) )
  1155.  
  1156. ; expandiert den CDR eines Lambda-Ausdrucks, ein (lambdalist . body). 2 Werte.
  1157. (defun %expand-lambdabody (lambdabody)
  1158.   (let ((body (rest lambdabody)))
  1159.     (if (and (consp body)
  1160.              (let ((form (car body)))
  1161.                (and (consp form)
  1162.                     (eq (car form) 'DECLARE)
  1163.                     (let ((declspecs (cdr form)))
  1164.                       (and (consp declspecs)
  1165.                            (let ((declspec (car declspecs)))
  1166.                              (and (consp declspec)
  1167.                                   (eq (car declspec) 'SOURCE)
  1168.         )    ) )    ) )    ) )
  1169.       (values lambdabody nil) ; bereits expandiert -> unberührt lassen
  1170.       (let ((*venv* *venv*))
  1171.         (values (list*
  1172.                   (%expand-lambdalist (first lambdabody))
  1173.                   (list 'DECLARE (list 'SOURCE lambdabody))
  1174.                   (%expand-list (rest lambdabody))
  1175.                 )
  1176.                 t
  1177. ) ) ) ) )
  1178.  
  1179. ; expandiert eine Lambdaliste. 2 Werte.
  1180. (defun %expand-lambdalist (ll)
  1181.   (if (atom ll)
  1182.     (if ll
  1183.       (error #+DEUTSCH "Lambdaliste darf nicht mit dem Atom ~S enden"
  1184.              #+ENGLISH "lambda list must not end with the atom ~S"
  1185.              #+FRANCAIS "La liste lambda ne peut pas se terminer par l'atome ~S"
  1186.              ll
  1187.       )
  1188.       (values nil nil)
  1189.     )
  1190.     (multiple-value-call #'%expand-cons ll
  1191.         (%expand-parspez (first ll))
  1192.         (progn
  1193.           (let ((v (first ll)))
  1194.             (if (not (member v lambda-list-keywords :test #'eq))
  1195.               (setq *venv* (vector (%expand-varspec-var v) nil *venv*))
  1196.           ) )
  1197.           (%expand-lambdalist (rest ll))
  1198. ) ) )   )
  1199.  
  1200. ; expandiert ein Element einer Lambdaliste. 2 Werte.
  1201. ; (Expandiert dabei nur bei Listen, und dann auch nur das zweite Element.)
  1202. (defun %expand-parspez (ps)
  1203.   (if (or (atom ps) (atom (rest ps)))
  1204.     (values ps nil)
  1205.     (multiple-value-call #'%expand-cons ps
  1206.         (first ps) nil
  1207.         (multiple-value-call #'%expand-cons (rest ps)
  1208.             (%expand-form (second ps))
  1209.             (cddr ps) nil
  1210. ) ) )   )
  1211.  
  1212. ; expandiert eine Variablenliste für LET. 2 Werte.
  1213. (defun %expand-varspez (vs &optional (nvenv nil))
  1214.   (if (atom vs)
  1215.     (if vs
  1216.       (error #+DEUTSCH "~S: Variablenliste endet mit dem Atom ~S"
  1217.              #+ENGLISH "~S: variable list ends with the atom ~S"
  1218.              #+FRANCAIS "~S : La liste de variables se termine par l'atome ~S"
  1219.              'let vs
  1220.       )
  1221.       (progn
  1222.         (setq *venv* (apply #'vector (nreverse (cons *venv* nvenv))))
  1223.         (values nil nil)
  1224.     ) )
  1225.     (multiple-value-call #'%expand-cons vs
  1226.         (%expand-parspez (first vs)) ; Bei Liste 2. Element expandieren
  1227.         (%expand-varspez (rest vs) (list* nil (%expand-varspec-var (first vs)) nvenv))
  1228. ) ) )
  1229.  
  1230. ; expandiert eine Variablenliste für LET*. 2 Werte.
  1231. (defun %expand-varspez* (vs)
  1232.   (if (atom vs)
  1233.     (if vs
  1234.       (error #+DEUTSCH "~S: Variablenliste endet mit dem Atom ~S"
  1235.              #+ENGLISH "~S: variable list ends with the atom ~S"
  1236.              #+FRANCAIS "~S : La liste de variables se termine par l'atome ~S"
  1237.              'let* vs
  1238.       )
  1239.       (values nil nil)
  1240.     )
  1241.     (multiple-value-call #'%expand-cons vs
  1242.         (%expand-parspez (first vs)) ; Bei Liste 2. Element expandieren
  1243.         (progn
  1244.           (setq *venv* (vector (%expand-varspec-var (first vs)) nil *venv*))
  1245.           (%expand-varspez* (rest vs))
  1246. ) ) )   )
  1247.  
  1248. (defun %expand-varspec-var (varspec)
  1249.   (if (atom varspec) varspec (first varspec))
  1250. )
  1251.  
  1252. (defun %expand-varspec-val (varspec)
  1253.   (if (atom varspec) nil (eval (second varspec)))
  1254. )
  1255.  
  1256. ; Expandiert eine Cond-Klausel-Liste. 2 Werte.
  1257. (defun %expand-cond (clauses)
  1258.   (if (atom clauses)
  1259.     (values clauses nil)
  1260.     (multiple-value-call #'%expand-cons clauses
  1261.         (%expand-list (first clauses))
  1262.         (%expand-cond (rest clauses))
  1263. ) ) )
  1264.  
  1265. ; Auf den bereits expandierten Body wird folgendes angewandt:
  1266. ; (%return-p name list) stellt fest, ob die Formenliste list irgendwo ein
  1267. ; (RETURN-FROM name ...) enthält.
  1268. (defun %return-p (name body)
  1269.   (block return-p
  1270.     (tagbody 1
  1271.       (if (atom body) (return-from return-p nil))
  1272.       (let ((form (car body)))
  1273.         (if
  1274.           ; stelle fest, ob form ein (RETURN-FROM name ...) enthält:
  1275.           (and (consp form)
  1276.                (or (and (eq (first form) 'return-from) ; (RETURN-FROM name ...)
  1277.                         (eq (second form) name)
  1278.                    )
  1279.                    (and (consp (first form))           ; Lambdaliste
  1280.                         (%return-p name (first form))
  1281.                    )
  1282.                    (and (not ; keine neue Definition desselben Blocks ?
  1283.                           (and (eq (first form) 'block) (eq (second form) name))
  1284.                         )
  1285.                         (%return-p name (rest form)) ; Funktionsaufruf
  1286.           )    )   )
  1287.           (return-from return-p t)
  1288.       ) )
  1289.       (setq body (cdr body))
  1290.       (go 1)
  1291. ) ) )
  1292.  
  1293. (defun %expand-varlist-macrop (l)
  1294.   (and (consp l)
  1295.        (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*)))
  1296.            (%expand-varlist-macrop (cdr l))
  1297. ) )    )
  1298.  
  1299. (defun %expand-setqlist-macrop (l)
  1300.   (and (consp l) (consp (cdr l))
  1301.        (or (and (symbolp (car l)) (symbol-macro-p (venv-assoc (car l) *venv*)))
  1302.            (%expand-setqlist-macrop (cddr l))
  1303. ) )    )
  1304.  
  1305. (defun %expand-setqlist (l)
  1306.   (if (or (atom l) (atom (cdr l)))
  1307.     (values l nil)
  1308.     (multiple-value-call #'%expand-cons l
  1309.         (first l) nil
  1310.         (multiple-value-call #'%expand-cons (rest l)
  1311.             (%expand-form (second l))
  1312.             (%expand-setqlist (cddr l))
  1313. ) ) )   )
  1314.  
  1315. ; (%expand-tagbody list) expandiert die Elemente einer Liste und läßt dabei
  1316. ; entstehende Atome fest (damit keine neuen Tags entstehen, die andere Tags
  1317. ; verdecken könnten). 2 Werte.
  1318. (defun %expand-tagbody (body)
  1319.   (cond ((atom body) (values body nil))
  1320.         ((atom (first body))
  1321.          (multiple-value-call #'%expand-cons body
  1322.              (first body) nil
  1323.              (%expand-tagbody (rest body))
  1324.         ))
  1325.         (t (multiple-value-bind (exp flag) (%expand-form (first body))
  1326.              (if (atom exp)
  1327.                (values (%expand-tagbody (rest body)) t) ; weglassen
  1328.                (multiple-value-call #'%expand-cons body
  1329.                    exp flag
  1330.                    (%expand-tagbody (rest body))
  1331. ) )     )  ) ) )
  1332. ; (%expand-fundefs-1 fundefs) liefert eine Liste (name1 nil ... namek nil *fenv*)
  1333. (defun %expand-fundefs-1 (fundefs)
  1334.   (if (atom fundefs)
  1335.     (if fundefs
  1336.       (error #+DEUTSCH "FLET/LABELS: Dotted list im Code, endet mit ~S"
  1337.              #+ENGLISH "FLET/LABELS: code contains a dotted list, ending with ~S"
  1338.              #+FRANCAIS "FLET/LABELS : une paire pointée dans le code, terminée par ~S"
  1339.              fundefs
  1340.       )
  1341.       (list *fenv*)
  1342.     )
  1343.     (let ((fundef (car fundefs)))
  1344.       (if (and (consp fundef) (function-name-p (car fundef)) (consp (cdr fundef)))
  1345.         (list* (car fundef) nil (%expand-fundefs-1 (cdr fundefs)))
  1346.         (error #+DEUTSCH "Falsche Syntax in FLET/LABELS: ~S"
  1347.                #+ENGLISH "illegal syntax in FLET/LABELS: ~S"
  1348.                #+FRANCAIS "syntaxe incorrecte dans FLET/LABELS : ~S"
  1349.                fundef
  1350. ) ) ) ) )
  1351. ; (%expand-fundefs-2 fundefs) expandiert eine Funktionsdefinitionenliste,
  1352. ; wie in FLET, LABELS. 2 Werte.
  1353. (defun %expand-fundefs-2 (fundefs)
  1354.   (if (atom fundefs)
  1355.     (values fundefs nil)
  1356.     (let ((fundef (car fundefs)))
  1357.       (multiple-value-call #'%expand-cons fundefs
  1358.              (multiple-value-call #'%expand-cons fundef
  1359.                      (car fundef) nil
  1360.                      (%expand-lambdabody (cdr fundef))
  1361.              )
  1362.              (%expand-fundefs-2 (rest fundefs))
  1363. ) ) ) )
  1364.  
  1365. #|
  1366. ; expandiert eine Form in einem gegebenen Function-Environment
  1367. ; Kann bei Bedarf von EVAL aufgerufen werden.
  1368. (defun %expand-form-main (form *fenv*)
  1369.   (%expand-form form)
  1370. )
  1371. |#
  1372.  
  1373. ; expandiert (lambdalist . body) in einem gegebenen Function-Environment.
  1374. ; Wird von GET_CLOSURE aufgerufen.
  1375. (defun %expand-lambdabody-main (lambdabody *venv* *fenv*)
  1376.   (%expand-lambdabody lambdabody)
  1377. )
  1378.  
  1379. (VALUES) )
  1380.  
  1381. ;; ab hier ist FUNCTION funktionsfähig, soweit kein MACROLET darin vorkommt.
  1382.  
  1383. (PROGN
  1384.  
  1385. (proclaim '(special *load-paths*))
  1386. (setq *load-paths* nil)
  1387.  
  1388. ; vorläufig brauchen die Files nicht gesucht zu werden:
  1389. (defun search-file (filename extensions)
  1390.   (mapcan #'(lambda (extension)
  1391.               (let ((filename (merge-pathnames filename extension)))
  1392.                 (if (probe-file filename) (list filename) '())
  1393.             ) )
  1394.           (reverse extensions)
  1395. ) )
  1396.  
  1397. (proclaim '(special *load-verbose*))
  1398. (setq *load-verbose* t)
  1399. (proclaim '(special *load-print*))
  1400. (setq *load-print* nil)
  1401. (proclaim '(special *load-echo*))
  1402. (setq *load-echo* nil)
  1403.  
  1404. ; (LOAD filename [:verbose] [:print] [:if-does-not-exist] [:echo] [:compiling]),
  1405. ; CLTL S. 426
  1406. (fmakunbound 'load)
  1407. (defun load (filename
  1408.              &key (verbose *load-verbose*) (print *load-print*) (if-does-not-exist t)
  1409.                   (echo *load-echo*) (compiling nil))
  1410.   (let ((stream
  1411.           (if (streamp filename)
  1412.             filename
  1413.             (or (open (setq filename (pathname filename))
  1414.                   :direction :input-immutable
  1415.                   :element-type 'string-char
  1416.                   :if-does-not-exist nil
  1417.                 )
  1418.                 ; Datei mit genau diesem Namen nicht vorhanden.
  1419.                 ; Suche unter den Dateien mit demselben Namen und den
  1420.                 ; Extensions "LSP", "FAS" die neueste:
  1421.                 (let ((present-files
  1422.                         (search-file filename '(#".lsp" #".fas"))
  1423.                      ))
  1424.                   (if (endp present-files)
  1425.                     nil
  1426.                     (open (setq filename (first present-files))
  1427.                           :direction :input-immutable
  1428.                           :element-type 'string-char
  1429.        )) ) )   ) ) )
  1430.     (if stream
  1431.       (let ((input-stream
  1432.               (if echo
  1433.                 (make-echo-stream stream *standard-output*)
  1434.                 stream
  1435.             ) )
  1436.             ; :verbose, :print und :echo wirken nicht rekursiv - dazu
  1437.             ; hat man ja gerade die Special-Variablen *load-verbose* etc.
  1438.             ;(*load-verbose* verbose)
  1439.             ;(*load-print* print)
  1440.             ;(*load-echo* echo)
  1441.             (*package* *package*) ; *PACKAGE* binden
  1442.             (*readtable* *readtable*) ; *READTABLE* binden
  1443.             (end-of-file "EOF")) ; einmaliges Objekt
  1444.         (when verbose
  1445.           (fresh-line)
  1446.           (write-string #+DEUTSCH ";; Datei "
  1447.                         #+ENGLISH ";; Loading file "
  1448.                         #+FRANCAIS ";; Chargement du fichier "
  1449.           )
  1450.           (princ filename)
  1451.           (write-string #+DEUTSCH " wird geladen..."
  1452.                         #+ENGLISH " ..."
  1453.                         #+FRANCAIS " ..."
  1454.         ) )
  1455.         (block nil
  1456.           (unwind-protect
  1457.             (tagbody weiter
  1458.               (when echo (fresh-line))
  1459.               (let ((obj (read input-stream nil end-of-file)))
  1460.                 (when (eql obj end-of-file) (return-from nil))
  1461.                 (setq obj
  1462.                   (multiple-value-list
  1463.                     (cond ((compiled-function-p obj) (funcall obj))
  1464.                           (compiling (funcall (compile-form obj nil nil nil nil nil)))
  1465.                           (t (eval obj))
  1466.                 ) ) )
  1467.                 (when print (when obj (print (first obj))))
  1468.               )
  1469.               (go weiter)
  1470.             )
  1471.             (close stream) (close input-stream)
  1472.         ) )
  1473.         (when verbose
  1474.           (fresh-line)
  1475.           (write-string #+DEUTSCH ";; Datei "
  1476.                         #+ENGLISH ";; Loading of file "
  1477.                         #+FRANCAIS ";; Le fichier "
  1478.           )
  1479.           (princ filename)
  1480.           (write-string #+DEUTSCH " ist geladen."
  1481.                         #+ENGLISH " is finished."
  1482.                         #+FRANCAIS " est chargé."
  1483.         ) )
  1484.         t
  1485.       )
  1486.       (if if-does-not-exist
  1487.         (error #+DEUTSCH "Ein Datei mit Namen ~A gibt es nicht."
  1488.                #+ENGLISH "A file with name ~A does not exist"
  1489.                #+FRANCAIS "Il n'existe pas de fichier de nom ~A."
  1490.                filename
  1491.         )
  1492.         nil
  1493.       )
  1494. ) ) )
  1495.  
  1496. ; vorläufig:
  1497. (sys::%putd 'defun
  1498.   (cons 'sys::macro
  1499.     (function defun
  1500.       (lambda (form env)
  1501.         (unless (and (consp (cdr form)) (consp (cddr form)))
  1502.           (error #+DEUTSCH "~S: Funktionsname und/oder Parameterliste fehlt"
  1503.                  #+ENGLISH "~S: missing function name and/or parameter list"
  1504.                  #+FRANCAIS "~S : Le nom de fonction et/ou la liste de paramètre manque"
  1505.                  'defun
  1506.         ) )
  1507.         (let ((name (cadr form))
  1508.               (lambdalist (caddr form))
  1509.               (body (cdddr form)))
  1510.           (unless (symbolp name)
  1511.             (error #+DEUTSCH "~S: ~S ist kein Symbol."
  1512.                    #+ENGLISH "~S: ~S is not a symbol."
  1513.                    #+FRANCAIS "~S : ~S n'est pas un symbole."
  1514.                    'defun name
  1515.           ) )
  1516.           (when (special-form-p name)
  1517.             (error #+DEUTSCH "~S: Spezialform ~S kann nicht umdefiniert werden."
  1518.                    #+ENGLISH "~S: special form ~S cannot be redefined."
  1519.                    #+FRANCAIS "~S : La forme spéciale ~S ne peut pas être redéfinie."
  1520.                    'defun name
  1521.           ) )
  1522.           (multiple-value-bind (body-rest declarations docstring)
  1523.                                (sys::parse-body body t env)
  1524.             (declare (ignore docstring))
  1525.             #|
  1526.             `(PROGN
  1527.                (SYS::%PUT ',name 'SYS::DEFINITION ',form)
  1528.                (SYS::%PUTD ',name
  1529.                  (FUNCTION ,name
  1530.                    (LAMBDA ,lambdalist
  1531.                      (DECLARE (SYS::IN-DEFUN ,name) ,@declarations)
  1532.                      (BLOCK ,name ,@body-rest)
  1533.                ) ) )
  1534.                ',name
  1535.              )
  1536.             |#
  1537.             (list 'progn
  1538.               (list 'sys::%put (list 'quote name) ''sys::definition
  1539.                     (list 'quote form)
  1540.               )
  1541.               (list 'sys::%putd (list 'quote name)
  1542.                 (list 'FUNCTION name
  1543.                   (list 'LAMBDA lambdalist
  1544.                         (list* 'DECLARE (list 'SYS::IN-DEFUN name) declarations)
  1545.                         (list* 'BLOCK name body-rest)
  1546.               ) ) )
  1547.               (list 'quote name)
  1548.             )
  1549.     ) ) ) )
  1550. ) )
  1551.  
  1552. ; vorläufige Definition des Macros DO :
  1553. (sys::%putd 'do
  1554.   (cons 'sys::macro
  1555.     (function do
  1556.       (lambda (form env)
  1557.         (let ((varclauselist (second form))
  1558.               (exitclause (third form))
  1559.               (body (cdddr form)))
  1560.           (when (atom exitclause)
  1561.             (error #+DEUTSCH "Exitclause in ~S muß Liste sein."
  1562.                    #+ENGLISH "exit clause in ~S must be a list"
  1563.                    #+FRANCAIS "La clause de sortie dans ~S doit être une liste."
  1564.                    'do
  1565.           ) )
  1566.           (let ((bindlist nil)
  1567.                 (reinitlist nil)
  1568.                 (bodytag (gensym))
  1569.                 (exittag (gensym)))
  1570.             (multiple-value-bind (body-rest declarations)
  1571.                                  (sys::parse-body body nil env)
  1572.               (block do
  1573.                 (tagbody 1
  1574.                   (when (atom varclauselist)
  1575.                     (return-from do
  1576.                       #|
  1577.                       `(block nil
  1578.                          (let ,(nreverse bindlist)
  1579.                            (declare ,@declarations)
  1580.                            (tagbody
  1581.                              (go ,exittag)
  1582.                              ,bodytag
  1583.                              ,@body-rest
  1584.                              (psetq ,@(nreverse reinitlist))
  1585.                              ,exittag
  1586.                              (or ,(first exitclause) (go ,bodytag))
  1587.                              (return-from nil (progn ,@(rest exitclause)))
  1588.                        ) ) )
  1589.                       |#
  1590.                       (list 'block 'nil
  1591.                         (list 'let (nreverse bindlist)
  1592.                           (cons 'declare declarations)
  1593.                           (list* 'tagbody
  1594.                             (list 'go exittag)
  1595.                             bodytag
  1596.                             (append body-rest
  1597.                               (list
  1598.                                 (cons 'psetq (nreverse reinitlist))
  1599.                                 exittag
  1600.                                 (list 'or (first exitclause) (list 'go bodytag))
  1601.                                 (list 'return-from 'nil
  1602.                                   (cons 'progn (rest exitclause))
  1603.                       ) ) ) ) ) )
  1604.                   ) )
  1605.                   (let ( (varclause (first varclauselist)) )
  1606.                        (setq varclauselist (rest varclauselist))
  1607.                        (cond ( (atom varclause)
  1608.                                   (setq bindlist
  1609.                                         (cons varclause bindlist)) )
  1610.                              ( (atom (cdr varclause))
  1611.                                   (setq bindlist
  1612.                                         (cons (first varclause) bindlist)) )
  1613.                              ( (atom (cddr varclause))
  1614.                                   (setq bindlist
  1615.                                         (cons varclause bindlist)) )
  1616.                              ( t (setq bindlist
  1617.                                        (cons (list (first varclause)
  1618.                                                    (second varclause))
  1619.                                              bindlist))
  1620.                                  (setq reinitlist
  1621.                                        (list* (third varclause)
  1622.                                               (first varclause)
  1623.                                               reinitlist)) )))
  1624.                   (go 1)
  1625.     ) ) ) ) ) ) )
  1626. ) )
  1627.  
  1628. ; vorläufige Definition des Macros DOTIMES :
  1629. (sys::%putd 'dotimes
  1630.   (cons 'sys::macro
  1631.     (function dotimes
  1632.       (lambda (form env)
  1633.         (let ((var (first (second form)))
  1634.               (countform (second (second form)))
  1635.               (resultform (third (second form)))
  1636.               (body (cddr form)))
  1637.           (multiple-value-bind (body-rest declarations)
  1638.                                (sys::parse-body body nil env)
  1639.             (let ((g (gensym)))
  1640.               #|
  1641.               `(DO ((,var 0 (1+ ,var))
  1642.                     (,g ,countform))
  1643.                    ((>= ,var ,g) ,resultform)
  1644.                  (declare ,@declarations)
  1645.                  ,@body-rest
  1646.                )
  1647.               |#
  1648.               (list* 'do (list (list var '0 (list '1+ var)) (list g countform))
  1649.                          (list (list '>= var g) resultform)
  1650.                      (cons 'declare declarations)
  1651.                      body-rest
  1652.               )
  1653.     ) ) ) ) )
  1654. ) )
  1655.  
  1656. (VALUES) )
  1657.  
  1658. ;; ab hier sind LOAD, DEFUN, DO, DOTIMES (eingeschränkt) funktionsfähig.
  1659.  
  1660. (LOAD "defseq")   ;; Definitionen von Standard-Sequences
  1661.  
  1662. (LOAD "backquot") ;; Backquote-Readmacro
  1663.  
  1664. (PROGN
  1665.  
  1666. (sys::%putd 'sys::backquote
  1667.   (cons 'sys::macro
  1668.     (function sys::backquote
  1669.       (lambda (form &optional env) (declare (ignore env)) (third form))
  1670. ) ) )
  1671.  
  1672. (VALUES) )
  1673.  
  1674. ;; ab hier ist Backquote funktionsfähig
  1675.  
  1676. (LOAD "defmacro")
  1677.  
  1678. ;; ab hier ist FUNCTION (uneingeschränkt) funktionsfähig.
  1679.  
  1680. (PROGN
  1681.  
  1682. (sys::%putd 'defmacro
  1683.   (cons 'sys::macro
  1684.     (function defmacro
  1685.       (lambda (form &optional env)
  1686.         (declare (ignore env))
  1687.         (multiple-value-bind (expansion name lambdalist docstring)
  1688.                              (sys::make-macro-expansion (cdr form))
  1689.           (declare (ignore lambdalist))
  1690.           `(LET ()
  1691.              (EVAL-WHEN (COMPILE LOAD EVAL)
  1692.                (SYSTEM::REMOVE-OLD-DEFINITIONS ',name)
  1693.                ,@(if docstring
  1694.                    `((SYSTEM::%SET-DOCUMENTATION ',name 'FUNCTION ',docstring))
  1695.                    '()
  1696.                  )
  1697.                (SYSTEM::%PUTD ',name (CONS 'SYSTEM::MACRO ,expansion))
  1698.              )
  1699.              (EVAL-WHEN (EVAL) (SYSTEM::%PUT ',name 'SYSTEM::DEFINITION ',form))
  1700.              ',name
  1701.            )
  1702.     ) ) )
  1703. ) )
  1704.  
  1705. (sys::%putd 'defun
  1706.   (cons 'sys::macro
  1707.     (function defun
  1708.       (lambda (form env)
  1709.         (if (atom (cdr form))
  1710.           (error #+DEUTSCH "~S: Daraus kann keine Funktion definiert werden: ~S"
  1711.                  #+ENGLISH "~S: cannot define a function from that: ~S"
  1712.                  #+FRANCAIS "~S : Pas de définition de fonction possible à partir de: ~S"
  1713.                  'defun (cdr form)
  1714.         ) )
  1715.         (unless (function-name-p (cadr form))
  1716.           (error #+DEUTSCH "~S: Der Name einer Funktion muß ein Symbol sein, nicht: ~S"
  1717.                  #+ENGLISH "~S: the name of a function must be a symbol, not ~S"
  1718.                  #+FRANCAIS "~S : Le nom d'une fonction doit être un symbole et non ~S"
  1719.                  'defun (cadr form)
  1720.         ) )
  1721.         (if (atom (cddr form))
  1722.           (error #+DEUTSCH "~S: Die Funktion ~S hat keine Lambdaliste."
  1723.                  #+ENGLISH "~S: function ~S is missing a lambda list"
  1724.                  #+FRANCAIS "~S : Il manque une liste lambda à la fonction ~S."
  1725.                  'defun (cadr form)
  1726.         ) )
  1727.         (let ((name (cadr form))
  1728.               (lambdalist (caddr form))
  1729.               (body (cdddr form)))
  1730.           (multiple-value-bind (body-rest declarations docstring)
  1731.                                (sys::parse-body body t env)
  1732.             (let ((symbolform
  1733.                     (if (atom name)
  1734.                       `',name
  1735.                       `(LOAD-TIME-VALUE (GET-SETF-SYMBOL ',(second name)))
  1736.                   ) )
  1737.                   (lambdabody
  1738.                     `(,lambdalist (DECLARE (SYS::IN-DEFUN ,name) ,@declarations)
  1739.                        (BLOCK ,(block-name name) ,@body-rest)
  1740.                      )
  1741.                  ))
  1742.               `(LET ()
  1743.                  (SYSTEM::REMOVE-OLD-DEFINITIONS ,symbolform)
  1744.                  ,@(if (and compiler::*compiling*
  1745.                             compiler::*compiling-from-file*
  1746.                             (member name compiler::*inline-functions* :test #'eq)
  1747.                             (null compiler::*venv*)
  1748.                             (null compiler::*fenv*)
  1749.                             (null compiler::*benv*)
  1750.                             (null compiler::*genv*)
  1751.                             (eql compiler::*denv* *toplevel-denv*)
  1752.                        )
  1753.                      ; Lambdabody für Inline-Compilation aufheben:
  1754.                      `((EVAL-WHEN (COMPILE)
  1755.                          (COMPILER::C-DEFUN ',name ',lambdabody)
  1756.                        )
  1757.                        (EVAL-WHEN (LOAD)
  1758.                          (SYSTEM::%PUT ,symbolform 'SYSTEM::INLINE-EXPANSION ',lambdabody)
  1759.                       ))
  1760.                      `((EVAL-WHEN (COMPILE) (COMPILER::C-DEFUN ',name)))
  1761.                    )
  1762.                  ,@(if docstring
  1763.                      `((SYSTEM::%SET-DOCUMENTATION ,symbolform 'FUNCTION ',docstring))
  1764.                      '()
  1765.                    )
  1766.                  (SYSTEM::%PUTD ,symbolform
  1767.                    (FUNCTION ,name (LAMBDA ,@lambdabody))
  1768.                  )
  1769.                  (EVAL-WHEN (EVAL) (SYSTEM::%PUT ,symbolform 'SYSTEM::DEFINITION ',form))
  1770.                  ',name
  1771.                )
  1772.     ) ) ) ) )
  1773. ) )
  1774.  
  1775. (VALUES) )
  1776.  
  1777. ;; ab hier sind DEFMACRO und DEFUN funktionsfähig.
  1778.  
  1779. ; (MACRO-EXPANDER . macrodef)                                         [Macro]
  1780. ; expandiert zum Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)).
  1781. (defmacro MACRO-EXPANDER (&body macrodef)
  1782.   (make-macro-expansion macrodef)
  1783. )
  1784.  
  1785. (LOAD "macros1")  ;; Kontrollstrukturen - Macros
  1786. (LOAD "macros2")  ;; weitere Macros
  1787.  
  1788. (LOAD "defs1")    ;; Definitionen zu Symbolen, Zahlen, Characters, Zeit
  1789.  
  1790. #+CLISP1 (LOAD "array") ;; Hilfsfunktionen für Arrays
  1791.  
  1792. (LOAD "places")   ;; SETF-Places: Definitionen und Macros
  1793.  
  1794. ;; ab hier ist SETF u.ä. funktionsfähig.
  1795.  
  1796. (LOAD "floatpri") ;; Ausgabe von Floating-Points
  1797.  
  1798. (LOAD "type")     ;; TYPEP
  1799.  
  1800. (LOAD "defstruc") ;; DEFSTRUCT-Macro
  1801.  
  1802. (LOAD "format")   ;; FORMAT
  1803.  
  1804. ; Ein Stückchen "DO-WHAT-I-MEAN":
  1805. ; Sucht ein Programm-File.
  1806. ; Gesucht wird im aktuellen Directory und dann in den Directories
  1807. ; aus *load-paths*.
  1808. ; Ist eine Extension angegeben, so wird nur nach Files mit genau dieser
  1809. ; Extension gesucht. Ist keine Extension angegeben, so wird nur nach Files
  1810. ; mit einer Extension aus der gegebenen Liste gesucht.
  1811. ; Man erhält alle Files aus dem ersten passenden Directory, als Pathnames,
  1812. ; in einer Liste, nach fallendem FILE-WRITE-DATE sortiert, oder NIL.
  1813. (defun search-file (filename extensions
  1814.                     &aux (use-extensions (null (pathname-type filename))) )
  1815.   (when use-extensions
  1816.     (setq extensions ; Case-Konversionen auf den Extensions durchführen
  1817.       (mapcar #'pathname-type extensions)
  1818.   ) )
  1819.   ; Defaults einmergen:
  1820.   (setq filename (merge-pathnames filename '#".*"))
  1821.   ; Suchen:
  1822.   (let ((already-searched nil))
  1823.     (dolist (dir (cons '#""
  1824.                        ; Wenn filename ".." enthält, zählt *load-paths* nicht
  1825.                        ; (um Errors wegen ".../../foo" z.B. auf DOS zu vermeiden):
  1826.                        (if (member #+(or ATARI DOS AMIGA VMS) :PARENT
  1827.                                    #+(or UNIX OS/2) ".."
  1828.                                    (pathname-directory filename)
  1829.                                    :test #'equal
  1830.                            )
  1831.                          '()
  1832.                          *load-paths*
  1833.             )    )     )
  1834.       (let ((search-filename
  1835.               (merge-pathnames (merge-pathnames filename dir))
  1836.            ))
  1837.         (unless (member search-filename already-searched :test #'equal)
  1838.           (let ((xpathnames (directory search-filename :full t)))
  1839.             (when use-extensions
  1840.               ; nach passenden Extensions filtern:
  1841.               (setq xpathnames
  1842.                 (delete-if-not ; hat xpathname eine der gegebenen Extensions?
  1843.                   #'(lambda (xpathname)
  1844.                       (member (pathname-type (first xpathname)) extensions
  1845.                               :test #-(or AMIGA OS/2) #'string=
  1846.                                     #+(or AMIGA OS/2) #'string-equal
  1847.                     ) )
  1848.                   xpathnames
  1849.             ) ) )
  1850.             (when xpathnames
  1851.               ; nach Datum sortiert, zurückgeben:
  1852.               (dolist (xpathname xpathnames)
  1853.                 (setf (rest xpathname)
  1854.                       (apply #'encode-universal-time (third xpathname))
  1855.               ) )
  1856.               (return (mapcar #'first (sort xpathnames #'> :key #'rest)))
  1857.           ) )
  1858.           (push search-filename already-searched)
  1859.     ) ) )
  1860. ) )
  1861.  
  1862. (LOAD "user1")    ;; User-Interface, Teil 1: Break-Loop, Stepper
  1863.  
  1864. (LOAD "user2")    ;; User-Interface, Teil 2: Apropos, Describe, Dribble, Ed
  1865.  
  1866. (LOAD "trace")    ;; User-Interface, Teil 3: TRACE
  1867.  
  1868. ;(LOAD "macros3")  ;; weitere Macros, optional
  1869.  
  1870. (LOAD "config")   ;; Konfigurations-Parameter
  1871.  
  1872. (LOAD "compiler") ;; Compiler
  1873.  
  1874. (LOAD "defs2")    ;; CLtL2-Definitionen, optional
  1875.  
  1876. (LOAD "clos")     ;; CLOS, optional
  1877.  
  1878. (when (find-package "SCREEN")
  1879.   (LOAD "screen") ;; Screen-Paket, optional
  1880. )
  1881.  
  1882. (when (find-package "STDWIN")
  1883.   (LOAD "stdwin") ;; STDWIN-Schnittstelle, optional
  1884. )
  1885.  
  1886. #+AMIGA (LOAD "rexx") ;; Rexx-Schnittstelle, optional
  1887.  
  1888. #+ATARI
  1889. (when (y-or-n-p #+DEUTSCH "Editor laden?"
  1890.                 #+ENGLISH "Load editor?"
  1891.                 #+FRANCAIS "Charger l'éditeur?"
  1892.       )
  1893.   (LOAD "editor") ;; Editor
  1894. )
  1895.  
  1896. (in-package "USER") ;; Default-Package aktuell machen
  1897.  
  1898.